{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Majalan.Base.EventList
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Event lists.
-- 
--------------------------------------------------------------------------------

module Majalan.Base.EventList
  ( 


    EventList
  , runEventList
  , displace
  
  , event
  , event_
  , eventFw
  , eventFw_

  -- * Time varying
  , eventB1
  , eventB2
  , eventB3
  , eventB4
  , eventB5

  , eventFwB1
  , eventFwB2
  , eventFwB3
  , eventFwB4
  , eventFwB5


  , impulses
  , impulsesFw

  , impulsesB1
  , impulsesFwB1

  )  where

import Majalan.Base.Behavior
import Majalan.Base.Context
import Majalan.Base.Event
import Majalan.Base.Impulse
import Majalan.Base.Internal.Base
import Majalan.Base.Internal.IStmt
import Majalan.Base.Internal.Utils

import Control.Applicative
import Control.Monad
import Data.Monoid




type InitialPos = Seconds

data Acc = Acc
    { acc_duration     :: !Seconds
    , acc_output_stmts :: !IStmtList
    }

instance Monoid Acc where
  mempty = Acc { acc_duration     = 0
               , acc_output_stmts = emptyH
               }
  Acc a1 b1 `mappend` Acc a2 b2 = 
      Acc { acc_duration     = max a1 a2
          , acc_output_stmts = b1 `appendH` b2
          }

data Ans a = Ans !Acc a



instance Functor Ans where
  fmap f (Ans w a) = Ans w (f a)


-- If Advance has Context then EventList show have Context...

newtype EventList uctx a = EventList { 
    getEventList :: Ctx uctx -> InitialPos -> Acc -> Ans a }

type instance UserCtx (EventList uctx) = uctx


instance Functor (EventList uctx) where
  fmap f ma = EventList $ \r start ac -> fmap f $ getEventList ma r start ac



instance Applicative (EventList uctx) where
  pure a    = EventList $ \_ _     ac -> Ans ac a
  mf <*> ma = EventList $ \r start ac -> 
                let Ans ac1 f = getEventList mf r start ac
                    Ans ac2 a = getEventList ma r start ac1
                in Ans ac2 (f a)

instance Monad (EventList uctx) where
  return    = pure
  ma >>= k  = EventList $ \r start ac -> 
                let Ans ac1 a = getEventList ma r start ac
                in getEventList (k a) r start ac1


instance Monoid a => Monoid (EventList uctx a) where
  mempty  = pure mempty
  mappend = overlay


instance ContextM (EventList uctx) where
  askCtx        = EventList $ \r _     ac -> Ans ac r
  localize f ma = EventList $ \r start ac -> 
                      getEventList ma (f r) start ac



runEventList :: Ctx uctx -> Seconds -> EventList uctx a 
             -> (TimeSpan, IStmtList, a)
runEventList ctx start ma = 
    let Ans (Acc drn istmts) a = getEventList ma ctx start mempty
        tspan                  = TimeSpan start drn
    in (tspan, istmts, a) 



-- only direct concatenation is overlay
               
overlay :: Monoid a 
        => EventList uctx a -> EventList uctx a 
        -> EventList uctx a
overlay ma mb = EventList $ \r start ac -> 
                    let Ans ac1 a = getEventList ma r start ac
                        Ans ac2 b = getEventList mb r start ac1
                    in Ans ac2 (a <> b)




displace :: Seconds -> EventList uctx a -> EventList uctx a
displace d ma = EventList $ \r start ac -> 
                  getEventList ma r (start + d) ac
                

-- horizontal concat is possible, but it would rely on timespan
-- being symbolically accurate vis note-lengths => wrong if notes
-- have sustain longer than their metric duration.




accDuration :: Onset -> Seconds -> TimeSpan -> Seconds
accDuration t0 d0 (TimeSpan t1 d1) = end - t0
  where
    end = max (t0 + d0) (t1 + d1)
   


-- Maybe event generates no impulse directly - join together 
-- with impulse if necessary (event_).





event :: Seconds -> Seconds -> Event uctx a -> EventList uctx a
event dt drn evt = EventList $ \r start (Acc d0 istmts0)  -> 
    let pos             = start + dt
        (stmts,tspan,a) = runEvent evt r pos drn
        acc1  = Acc { acc_duration     = accDuration start d0 tspan
                    , acc_output_stmts = istmts0 `appendH` stmts
                    }
    in Ans acc1 a

event_ :: Seconds -> Seconds -> Event uctx a -> EventList uctx ()
event_ dt drn evt = void $ event dt drn evt

-- think we need forgetful _and_ memorable versions...


eventFw :: Seconds -> EventFw uctx a -> EventList uctx a
eventFw dt evt = EventList $ \r start (Acc d0 istmts0)  -> 
    let pos             = start + dt
        (stmts,tspan,a) = runEventFw evt r pos 
        acc1  = Acc { acc_duration     = accDuration start d0 tspan
                    , acc_output_stmts = istmts0 `appendH` stmts
                    }
    in Ans acc1 a

eventFw_ :: Seconds -> EventFw uctx a -> EventList uctx ()
eventFw_ dt evt = void $ eventFw dt evt


-- EventList no longer supports impulse - we need a new 
-- Advance/path-like object with explicit impulses 


--------------------------------------------------------------------------------
-- Time varying events

-- Should behavior be the first argument? Or after onset and 
-- duration?
--
-- >          do { eventB1 beh1 0 1 $ bowedBar 0.8 0.1 
-- >             ; eventB1 beh1 1 1 $ bowedBar 0.7 0.1
-- >             } 
-- 
-- >          do { eventB1 0 1 beh1 $ bowedBar 0.8 0.1 
-- >             ; eventB1 1 1 beh1 $ bowedBar 0.7 0.1
-- >             } 


eventB1 :: Seconds -> Seconds 
        -> Behavior b1 
        -> EventB1 b1 uctx a
        -> EventList uctx a
eventB1 = withBehavior1_drn event


eventB2 :: Seconds -> Seconds 
        -> Behavior b1 -> Behavior b2 
        -> EventB2 b1 b2 uctx a
        -> EventList uctx a
eventB2 = withBehavior2_drn event


eventB3 :: Seconds -> Seconds 
        -> Behavior b1 -> Behavior b2 -> Behavior b3
        -> EventB3 b1 b2 b3 uctx a
        -> EventList uctx a
eventB3 = withBehavior3_drn event


eventB4 :: Seconds -> Seconds 
        -> Behavior b1 -> Behavior b2 -> Behavior b3 -> Behavior b4
        -> EventB4 b1 b2 b3 b4 uctx a
        -> EventList uctx a
eventB4 = withBehavior4_drn event


eventB5 :: Seconds -> Seconds 
        -> Behavior b1 -> Behavior b2 
        -> Behavior b3 -> Behavior b4 -> Behavior b5
        -> EventB5 b1 b2 b3 b4 b5 uctx a
        -> EventList uctx a
eventB5 = withBehavior5_drn event




-- Fixed width

eventFwB1 :: Seconds 
          -> Behavior b1 
          -> EventFwB1 b1 uctx a 
          -> EventList uctx a
eventFwB1 = withBehavior1_no_drn eventFw


eventFwB2 :: Seconds 
          -> Behavior b1 -> Behavior b2
          -> EventFwB2 b1 b2 uctx a 
          -> EventList uctx a
eventFwB2 = withBehavior2_no_drn eventFw


eventFwB3 :: Seconds 
          -> Behavior b1 -> Behavior b2 -> Behavior b3
          -> EventFwB3 b1 b2 b3 uctx a 
          -> EventList uctx a
eventFwB3 = withBehavior3_no_drn eventFw


eventFwB4 :: Seconds 
          -> Behavior b1 -> Behavior b2 -> Behavior b3 -> Behavior b4
          -> EventFwB4 b1 b2 b3 b4 uctx a 
          -> EventList uctx a
eventFwB4 = withBehavior4_no_drn eventFw


eventFwB5 :: Seconds 
          -> Behavior b1 -> Behavior b2 -> Behavior b3 
          -> Behavior b4 -> Behavior b5
          -> EventFwB5 b1 b2 b3 b4 b5 uctx a 
          -> EventList uctx a
eventFwB5 = withBehavior5_no_drn eventFw




--------------------------------------------------------------------------------
-- Helpers for behavior versions...


getEventTime :: Seconds -> EventList uctx Seconds
getEventTime dt = EventList $ \_ start ac -> Ans ac (start + dt)

-- With duration...

withBehavior1_drn :: (Seconds -> Seconds -> a -> EventList uctx ans)
                  -> Seconds -> Seconds -> Behavior b1 -> (b1 -> a)
                  -> EventList uctx ans
withBehavior1_drn mf dt drn beh1 fn = do
    ot      <- getEventTime dt
    let a1  = applyBeh beh1 ot
    mf dt drn (fn a1)

withBehavior2_drn :: (Seconds -> Seconds -> a -> EventList uctx ans)
                  -> Seconds -> Seconds 
                  -> Behavior b1 -> Behavior b2
                  -> (b1 -> b2 -> a)
                  -> EventList uctx ans
withBehavior2_drn mf dt drn beh1 beh2 fn = do
    ot      <- getEventTime dt
    let a1  = applyBeh beh1 ot
    let a2  = applyBeh beh2 ot
    mf dt drn (fn a1 a2)


withBehavior3_drn :: (Seconds -> Seconds -> a -> EventList uctx ans)
                  -> Seconds -> Seconds 
                  -> Behavior b1 -> Behavior b2 -> Behavior b3
                  -> (b1 -> b2 -> b3 -> a)
                  -> EventList uctx ans
withBehavior3_drn mf dt drn beh1 beh2 beh3 fn = do
    ot      <- getEventTime dt
    let a1  = applyBeh beh1 ot
    let a2  = applyBeh beh2 ot
    let a3  = applyBeh beh3 ot
    mf dt drn (fn a1 a2 a3)


withBehavior4_drn :: (Seconds -> Seconds -> a -> EventList uctx ans)
                  -> Seconds -> Seconds 
                  -> Behavior b1 -> Behavior b2 -> Behavior b3 -> Behavior b4
                  -> (b1 -> b2 -> b3 -> b4 -> a)
                  -> EventList uctx ans
withBehavior4_drn mf dt drn beh1 beh2 beh3 beh4 fn = do
    ot      <- getEventTime dt
    let a1  = applyBeh beh1 ot
    let a2  = applyBeh beh2 ot
    let a3  = applyBeh beh3 ot
    let a4  = applyBeh beh4 ot
    mf dt drn (fn a1 a2 a3 a4)


withBehavior5_drn :: (Seconds -> Seconds -> a -> EventList uctx ans)
                  -> Seconds -> Seconds 
                  -> Behavior b1 -> Behavior b2 -> Behavior b3 
                  -> Behavior b4 -> Behavior b5
                  -> (b1 -> b2 -> b3 -> b4 -> b5 -> a)
                  -> EventList uctx ans
withBehavior5_drn mf dt drn beh1 beh2 beh3 beh4 beh5 fn = do
    ot      <- getEventTime dt
    let a1  = applyBeh beh1 ot
    let a2  = applyBeh beh2 ot
    let a3  = applyBeh beh3 ot
    let a4  = applyBeh beh4 ot
    let a5  = applyBeh beh5 ot
    mf dt drn (fn a1 a2 a3 a4 a5)



-- No duration...

withBehavior1_no_drn :: (Seconds -> a -> EventList uctx ans)
                     -> Seconds -> Behavior b1 -> (b1 -> a)
                     -> EventList uctx ans
withBehavior1_no_drn mf dt beh1 fn = do
    ot      <- getEventTime dt
    let a1  = applyBeh beh1 ot
    mf dt (fn a1)
    

withBehavior2_no_drn :: (Seconds -> a -> EventList uctx ans)
                     -> Seconds 
                     -> Behavior b1 -> Behavior b2
                     -> (b1 -> b2 -> a)
                     -> EventList uctx ans
withBehavior2_no_drn mf dt beh1 beh2 fn = do
    ot      <- getEventTime dt
    let a1  = applyBeh beh1 ot
    let a2  = applyBeh beh2 ot
    mf dt (fn a1 a2)


withBehavior3_no_drn :: (Seconds -> a -> EventList uctx ans)
                     -> Seconds 
                     -> Behavior b1 -> Behavior b2 -> Behavior b3
                     -> (b1 -> b2 -> b3 -> a)
                     -> EventList uctx ans
withBehavior3_no_drn mf dt beh1 beh2 beh3 fn = do
    ot      <- getEventTime dt
    let a1  = applyBeh beh1 ot
    let a2  = applyBeh beh2 ot
    let a3  = applyBeh beh3 ot
    mf dt (fn a1 a2 a3)


withBehavior4_no_drn :: (Seconds -> a -> EventList uctx ans)
                     -> Seconds 
                     -> Behavior b1 -> Behavior b2 -> Behavior b3 
                     -> Behavior b4
                     -> (b1 -> b2 -> b3 -> b4 -> a)
                     -> EventList uctx ans
withBehavior4_no_drn mf dt beh1 beh2 beh3 beh4 fn = do
    ot      <- getEventTime dt
    let a1  = applyBeh beh1 ot
    let a2  = applyBeh beh2 ot
    let a3  = applyBeh beh3 ot
    let a4  = applyBeh beh4 ot
    mf dt (fn a1 a2 a3 a4)


withBehavior5_no_drn :: (Seconds -> a -> EventList uctx ans)
                     -> Seconds 
                     -> Behavior b1 -> Behavior b2 -> Behavior b3 
                     -> Behavior b4 -> Behavior b5
                     -> (b1 -> b2 -> b3 -> b4 -> b5 -> a)
                     -> EventList uctx ans
withBehavior5_no_drn mf dt beh1 beh2 beh3 beh4 beh5 fn = do
    ot      <- getEventTime dt
    let a1  = applyBeh beh1 ot
    let a2  = applyBeh beh2 ot
    let a3  = applyBeh beh3 ot
    let a4  = applyBeh beh4 ot
    let a5  = applyBeh beh5 ot
    mf dt (fn a1 a2 a3 a4 a5)




--------------------------------------------------------------------------------
-- Rendering ImpulseMaps


-- Can have a version with pair of functions to get (b) and 
-- (duration) from ImpulseMap val...



impulses :: (impl -> Seconds, impl -> a) 
         -> ImpulseMap impl -> (a -> Event uctx z)
         -> EventList uctx ()
impulses (getD, getVal) imp mf = 
    mapM_ (\(ot,a) -> event ot (getD a) (mf $ getVal a)) $ toImpulseList imp


impulsesFw :: ImpulseMap impl -> (impl -> EventFw uctx z) -> EventList uctx ()
impulsesFw imp mf = mapM_ (\(ot,a) -> eventFw ot (mf a)) $ toImpulseList imp


-- TODO - Behavior versions ...
-- Note - what is the time extent of a behavior - length of whole 
-- track, or length of some music object?

impulsesB1 :: (impl -> Seconds, impl -> a) 
           -> ImpulseMap impl -> Behavior b1 -> (a -> EventB1 b1 uctx z)
           -> EventList uctx ()
impulsesB1 (getD,getVal) imp beh1 mf = 
    mapM_ (\(ot,a) -> eventB1 ot (getD a) beh1 (mf $ getVal a)) $ toImpulseList imp


impulsesFwB1 :: ImpulseMap impl 
             -> Behavior b1 
             -> (impl -> EventFwB1 b1 uctx z) 
             -> EventList uctx ()
impulsesFwB1 imp beh1 mf = mapM_ (\(ot,a) -> eventFwB1 ot beh1 (mf a)) $ toImpulseList imp
